home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 8: LINUX Games / Linux Cubed Series 8 - LINUX Games.iso / games / role / roleplay.0-s / roleplay / RolePlaying-1.0 / scripts / topgetopt.tcl < prev    next >
Text File  |  1995-07-09  |  4KB  |  124 lines
  1. #
  2. # topgetopt.tcl
  3. #
  4. # The function has "top" prefix b/c it is conceptually part of my "top" library.
  5. #
  6. # Authors: Kennard White (kennard@ohm.berkeley.edu)
  7. #       Phil Lapsley (phil@ohm.berkeley.edu)
  8. #
  9. # Based on "@(#)getopt.tcl 1.5 12/7/91" by Phil Lapsley
  10. # RCS: $Header: /home/heller/Deepwoods/RolePlaying/RCS/topgetopt.tcl,v 1.1 1995/07/09 22:09:28 heller Exp $
  11. #
  12.  
  13. # Ignore this; its used by some custom auto-reload software
  14. proc topgetopt.tcl { } { }
  15.  
  16. # Simple "getopt" for TCL.
  17. #
  18. # topgetopt ?-any? ?-all? opt_list arg_list
  19. # The proc will process the arguments in {arg_list} according to the
  20. # information in {opt_list}.  Processed arguments are passed back
  21. # to the caller by setting variables in the caller's proc-environment
  22. # (i.e., using upvar).
  23. #
  24. # option_list is a list of option specs.  Each spec is a 3-tuple:
  25. #    { optname varname mode }
  26. # optname is the name of the option to be parsed (without the leading dash).
  27. # varname is the name of a tcl variable in the caller's environment.
  28. #    If ommitted, the varname defaults to the optname.
  29. # mode describes the type of option. If ommitted, it defaults to "single".
  30. #    The modes:
  31. #       single:    sets the variable to the next argument.
  32. #       append:    lappends the next argument to the variable.
  33. #            this allows multiple instances of the same option.
  34. #      boolean:    sets the variable to 0 if the argument prefix is "+"
  35. #             and to 1 of the argument prefix is "-".
  36. #
  37. # "topgetopt" sets the variables named in the option_list that were
  38. # specified in arg_list, and returns the remainder of arg_list after
  39. # the first non "-" or "+" option.  If a bad option specifier is
  40. # encountered, scanning stops and getopt aborts using error.
  41. #
  42. # If -all is specified, then everything in arg_list must match an
  43. # option in opt_list; that is, there may be no "leftover" arguments.
  44. #
  45. # If -any is specified, then processing will stop at the first
  46. # unmatched option.  That is, the returned list of unprocessed
  47. # arguments may contain unregcognized options.
  48. #
  49. # For example, the option_list:
  50. #
  51. #    { min max { file filename } { toplevel toplevel boolean } }
  52. #
  53. # means that the option "-min value" or "-max value" should set the
  54. # variables "min" or "max" to the specified value, and "-file value"
  55. # should set the variable "filename" to the specified value.  "toplevel"
  56. # sets the variable "toplevel", and is a boolean.  I.e., the -toplevel
  57. # option takes no argument.
  58. #
  59. # In typical usage, the caller will first initialize all the option
  60. # variables to default values, and then call getopt.
  61. #
  62.  
  63. proc topgetopt { args } {
  64.     set do_all 0
  65.     set do_any 0
  66.     if { "[lindex $args 0]"=="-all" } {
  67.     set do_all 1
  68.     set args [lreplace $args 0 0]
  69.     }
  70.     if { "[lindex $args 0]"=="-any" } {
  71.     set do_any 1
  72.     set args [lreplace $args 0 0]
  73.     }
  74.     if { [llength $args]!=2 } {
  75.     error "topgetopt: programming error: wrong number arguments\n$args"
  76.     }
  77.     set opt_list [lindex $args 0]
  78.     set arg_list [lindex $args 1]
  79.  
  80.     set n [llength $arg_list]
  81.     for { set i 0 } { $i < $n } { incr i } {
  82.     set arg [lindex $arg_list $i]
  83.     set argkey [string index $arg 0]
  84.     if { "$argkey"!="-" && "$argkey"!="+" } {
  85.         if { $do_all } {
  86.         error "Extra arguments after options not allowed: ``$arg''"
  87.         }
  88.         break
  89.     }
  90.     set argname [string range $arg 1 end]
  91.     set matched 0
  92.     foreach opt $opt_list {
  93.         if { "[lindex $opt 0]"=="$argname" } {
  94.         set optlen [llength $opt]
  95.         set pntVar pntVar$i
  96.         upvar 1 [lindex $opt [expr { ($optlen > 1) ? 1 : 0 }]] $pntVar
  97.         # lindex returns empty string for out-of-range
  98.         case [lindex $opt 2] {
  99.           b* {
  100.             set $pntVar [expr {"$argkey"=="-" ? 1 : 0}]
  101.           }
  102.           a* {
  103.             lappend $pntVar [lindex $arg_list [incr i 1] ]
  104.           }
  105.               default {
  106.             set $pntVar [lindex $arg_list [incr i 1] ]
  107.           }
  108.         }
  109. # puts stdout "got [lindex $opt 0] -- [lindex $opt 1] -- [set $pntVar]"
  110.         set matched 1
  111.         break
  112.         }
  113.     }
  114.     if { $matched == 0 } {
  115.         if { $do_any } {
  116.         break
  117.         } else {
  118.             error "No match for argument ``$arg''"
  119.         }
  120.     }
  121.     }
  122.     return [lrange $arg_list $i end]
  123. }
  124.